home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / language / xlispst.cpt / XLisp-Stat ƒ / Disk 1 / graphics3.lsp < prev    next >
Encoding:
Text File  |  1990-03-06  |  8.5 KB  |  229 lines
  1. (provide "graphics3")
  2. (require "graphics")
  3.  
  4. ;;;
  5. ;;; Options dialog stuff
  6. ;;;
  7.  
  8. (defproto graph-toggle-item-proto '(graph message) () toggle-item-proto)
  9.  
  10. (defmeth graph-toggle-item-proto :isnew (title graph message)
  11.   (setf (slot-value 'graph) graph)
  12.   (setf (slot-value 'message) message)
  13.   (call-next-method title :value (send graph message)))
  14.  
  15. (defmeth graph-toggle-item-proto :set-value ()
  16.   (let* ((message (slot-value 'message))
  17.          (graph (slot-value 'graph))
  18.          (old (if (send graph message) t nil))
  19.          (new (if (send self :value) t nil)))
  20.     (unless (eq old new) (send graph message new))))
  21.  
  22. (defproto graph-backcolor-choice-item-proto '(graph) () choice-item-proto)
  23.  
  24. (defmeth graph-backcolor-choice-item-proto :isnew (graph)
  25.   (setf (slot-value 'graph) graph)
  26.   (call-next-method (list "White Background" "Black Background") 
  27.                     :value (if (eq (send graph :back-color) 'white) 0 1)))
  28.  
  29. (defmeth graph-backcolor-choice-item-proto :set-value ()
  30.   (let ((graph (slot-value 'graph)))
  31.     (case (send self :value)
  32.       (0 (send graph :back-color 'white)
  33.          (send graph :draw-color 'black))
  34.       (1 (send graph :back-color 'black)
  35.          (send graph :draw-color 'white)))))
  36.  
  37. (defproto graph-scaling-choice-item-proto '(graph) () choice-item-proto)
  38.  
  39. (defmeth graph-scaling-choice-item-proto :isnew (graph)
  40.   (setf (slot-value 'graph) graph)
  41.   (call-next-method (list "Variable Scaling" "Fixed Scaling" "No Scaling")
  42.                     :value (case (send graph :scale-type) 
  43.                                  (variable 0)
  44.                                  (fixed 1) 
  45.                                  (t 2))))
  46.  
  47. (defmeth graph-scaling-choice-item-proto :set-value ()
  48.   (let ((graph (slot-value 'graph)))
  49.     (send graph :scale-type
  50.           (case (send self :value)
  51.                 (0 'variable)
  52.                 (1 'fixed)
  53.                 (2 nil)))))
  54.  
  55. (defmeth graph-proto :set-options ()
  56. "Method args: ()
  57. Opens dialog to set plot options. Items are obtained using the
  58. :make-options-dialog-items message."
  59.   (let* ((items (send self :make-options-dialog-items))
  60.          (d (send ok-or-cancel-dialog-proto :new items :title "Options"
  61.                   :ok-action #'(lambda ()
  62.                                  (dolist (i items) 
  63.                                          (send i :set-value))
  64.                                  (send self :redraw)))))
  65.     (unwind-protect (send d :modal-dialog)
  66.                     (send d :remove))))
  67.  
  68. (defmeth graph-proto :make-options-dialog-items ()
  69.   (list (send graph-backcolor-choice-item-proto :new self)
  70.         (send graph-toggle-item-proto :new "Vertical Scroll" self :has-v-scroll)
  71.         (send graph-toggle-item-proto :new "Horizontal Scroll" self :has-h-scroll)
  72.         (send graph-toggle-item-proto :new "Fixed Aspect Ratio" self :fixed-aspect)
  73. #+color (send graph-toggle-item-proto :new "Use color" self :use-color)))
  74.  
  75. (defmeth scatmat-proto :make-options-dialog-items ()
  76.   (list (send graph-backcolor-choice-item-proto :new self)
  77.         (send graph-toggle-item-proto :new "Vertical Scroll" self :has-v-scroll)
  78.         (send graph-toggle-item-proto :new "Horizontal Scroll" self :has-h-scroll)
  79. #+color (send graph-toggle-item-proto :new "Use color" self :use-color)))
  80.  
  81. (defmeth spin-proto :make-options-dialog-items ()
  82.   (list 
  83.         (send graph-backcolor-choice-item-proto :new self)
  84.     (send graph-scaling-choice-item-proto :new self)
  85. #+color (send graph-toggle-item-proto :new "Use color" self :use-color)))
  86.  
  87. ;;;;
  88. ;;;;
  89. ;;;; Plot Sliders and Slicers
  90. ;;;;
  91. ;;;;
  92.  
  93. ;;; Graph dialogs
  94.  
  95. (defproto graph-dialog-proto '(plot))
  96.  
  97. (defmeth graph-dialog-proto :install (plot)
  98.   (setf (slot-value 'plot) plot)
  99.   (send plot :add-subordinate self))
  100.  
  101. (defmeth graph-dialog-proto :clobber ()
  102.   (let ((plot (slot-value 'plot)))
  103.     (if plot (send plot :delete-subordinate self)))
  104.   (setf (slot-value 'plot) nil))
  105.  
  106. ;;; Graph slicers
  107.  
  108. (defmeth graph-proto :add-slicer (s)
  109.   (setf (slot-value 'slicers) (adjoin s (slot-value 'slicers)))
  110.   (if (send self :allocated-p) (send self :adjust-slices)))
  111.   
  112. (defmeth graph-proto :remove-slicer (s)
  113.   (setf (slot-value 'slicers) (remove s (slot-value 'slicers)))
  114.   (when (send self :allocated-p)
  115.         (if (eq 'show (send s :type)) (send self :show-all-points))
  116.         (send self :adjust-slices)))
  117.  
  118. (defproto graph-slicer-proto
  119.           '(variable delta selecting)
  120.           () 
  121.           (list graph-dialog-proto interval-slider-dialog-proto))
  122.  
  123. (defmeth graph-slicer-proto :isnew (plot var delta range
  124.                                          &rest args
  125.                                          &key select)
  126.   (setf (slot-value 'variable) var)
  127.   (setf (slot-value 'delta) delta)
  128.   (setf (slot-value 'selecting) select)
  129.   (apply #'call-next-method range 
  130.          :action #'(lambda (x) (send plot :adjust-slices)) args)
  131.   (send self :install plot))
  132.  
  133. (defmeth graph-slicer-proto :install (plot)
  134.   (call-next-method plot)
  135.   (send plot :add-slicer self))
  136.   
  137. (defmeth graph-slicer-proto :clobber ()
  138.   (let ((plot (slot-value 'plot)))
  139.     (if plot (send plot :remove-slicer self)))
  140.   (call-next-method))
  141.  
  142. (defmeth graph-slicer-proto :selection ()
  143.   (let ((x (send self :value))
  144.         (var (slot-value 'variable))
  145.         (d (slot-value 'delta)))
  146.     (which (< (- x d) var (+ x d)))))
  147.  
  148. (defmeth graph-slicer-proto :type ()
  149.   (if (slot-value 'selecting) 'select 'show))
  150.   
  151. (defmeth graph-proto :adjust-slices ()
  152.   (cond
  153.     ((slot-value 'slicers)
  154.      (let ((indices (reduce #'intersection 
  155.                             (mapcar #'(lambda (x) (send x :selection))
  156.                                     (slot-value 'slicers))))
  157.             (show (some #'(lambda (x) (eq 'show (send x :type))) 
  158.                         (slot-value 'slicers))))
  159.        (cond
  160.          (show (send self :points-showing indices))
  161.          (t (send self :points-selected indices)))))
  162.     (t (send self :unselect-all-points) (send self :show-all-points))))   
  163.  
  164. ;; Installing graph slicers
  165.  
  166. (defmeth graph-proto :slicer (var &rest args 
  167.                                   &key 
  168.                                   (fraction 0.25)
  169.                                   title
  170.                                   (points 20))
  171.   (unless title (setq title "Slicer"))
  172.   (let* ((range (list (min var) (max var)))
  173.          (p (* 0.5  fraction (- (nth 1 range) (nth 0 range))))
  174.          (plot self)
  175.          (slicer (apply #'send graph-slicer-proto :new self var p
  176.                         (list (+ (nth 0 range) p) (- (nth 1 range) p))
  177.                         :title title
  178.                         :points points
  179.                         args)))
  180.     (send slicer :value (/ (+ (nth 0 range) (nth 1 range)) 2))
  181.     slicer))
  182.     
  183. (defmeth graph-proto :make-slicer-dialog ()
  184.   (let* ((fractions (list 0.1 0.2 0.3))
  185.          (var-item (send edit-text-item-proto :new 
  186.                          (format nil "(iseq 0 ~d)          " 
  187.                                  (- (send self :num-points) 1))))
  188.          (fraction-item (send choice-item-proto :new 
  189.                               (mapcar #'(lambda (x) (format nil "~a" x))
  190.                                       fractions) 
  191.                               :value 1))
  192.          (type-item (send choice-item-proto :new 
  193.                           (list "Select Slice"
  194.                                 "Show Only Slice")))
  195.          expr
  196.          title
  197.          var
  198.          fraction
  199.          select
  200.          ok)
  201.     (flet ((ok-action ()
  202.                       (setq expr (read (make-string-input-stream 
  203.                                         (send var-item :text))))
  204.                       (setq title (format nil "~a" expr))
  205.                       (setq var (eval expr))
  206.                       (setq fraction (nth (send fraction-item :value)
  207.                                           fractions))
  208.                       (setq select (= 0 (send type-item :value)))
  209.                       t))
  210.       (let* ((d (send ok-or-cancel-dialog-proto :new 
  211.                       (list (send text-item-proto :new "Variable")
  212.                             var-item
  213.                             (list (list 
  214.                                    (send text-item-proto :new "Fraction")
  215.                                    fraction-item)
  216.                                   (list 
  217.                                    (send text-item-proto :new "Slicer Type")
  218.                                    type-item)))
  219.                       :ok-action #'ok-action)))
  220.         (unwind-protect (setq ok (send d :modal-dialog))
  221.                         (send d :remove))))
  222.     (if ok 
  223.         (send self :slicer var 
  224.               :title title 
  225.               :fraction fraction 
  226.               :select select))))
  227.               
  228.         
  229.